module MyData.Form
( F(..)
, f2l, l2f
, S, t, nil, typeOf
, mapCar, mapCar', mapCar'', mapCons
, Evol, Eval, assoc, bind, evalArgs, prog, label, applyComma
, synDot, synAMC, synAMC', synCMC, synCMC', withMagic, genMagic
, np, pr
) where

data F s = A{fromA::s} | C (F s) (F s) deriving (Eq)
f2l :: F s -> [s]
f2l = foldr (:) []
l2f :: Foldable t => F s -> t (F s) -> F s
l2f nil = foldr C nil

---- Form String
type S = String
nil = A ""
t = C nil nil
typeOf f = case f of A _ -> nil; _ -> t

---- General
mapCar :: (F s->F s) -> F s -> F s
mapCar fun = mapCar' (fun,id)
mapCar' (carFun,atomCdrFun) = mapCar'' (carFun,atomCdrFun,C)
mapCar'' (carFun,atomCdrFun,combFun) a@(A _) = atomCdrFun a
mapCar'' funs@(carFun,atomCdrFun,combFun) a@(C x y) = carFun x `combFun` mapCar'' funs y
mapCons :: (F s->F s->F s) -> F s -> F s
mapCons fun a@(A _) = a
mapCons fun c@(C x y) = mapCons fun x `fun` mapCons fun y

---- eval
type Evol s = (F s,F s) -- (env,f)
type Eval s = F s -> F s -> Evol s
assoc :: Eq s => F s -> F s -> Maybe (F s)
assoc env@(A _) a = Nothing
assoc (C (C n v) restEnv) a = if a==n then Just v else assoc restEnv a
bind :: ((s->Bool),F s) -> (F s,F s) -> F s
-- db: don't bind
bind (db,env) (fa@(A s),ra) = if db s then env else C fa ra `C` env
bind (db,env) (fa@(C x y),ra@(A _)) = let env'=bind (db,env) (y,ra) in bind (db,env') (x,ra)
bind (db,env) (fa@(C x y),ra@(C x' y')) = let env'=bind (db,env) (y,y') in bind (db,env') (x,x')
evalArgs :: Eval s -> Evol s -> F s
evalArgs eval (env,args) = mapCar ve args where ve=fst . eval env
prog :: Eval s -> F s -> F s -> F s
prog eval env (C f (A _)) = snd $ eval env f
prog eval env (C f rest) = let (env',_)=eval env f in prog eval env' rest
label :: (Eval s,F s->F s->F s->F s) -> (F s,F s,F s,F s,F s,F s) -> F s
label (eval,bindArg) (env,labForm,labName,fa,fb,ra) = let env'=C labName labForm `C` bindArg env fa ra in prog eval env' fb -- bind labName to labForm for recursion
applyComma :: (F S->F S) -> S -> F S
applyComma ve (',':c:cs) = ve $ A $ c:cs
applyComma ve str = A str

---- syn
synDot = mapCons transDot where
  transDot x (C (A ".") (C y (A ""))) = x `C` y
  transDot x y = C x y
-- AMC: atom magic char
synAMC cs prefix = synAMC' $ genMagic cs prefix
synAMC' :: (c->Bool,c->F[c]->F[c]) -> F[c] -> F[c]
synAMC' p f = f >>= transAMC p where
  transAMC p@(am,wam) s@(c:cs@(_:_)) = if am c then wam c $ synAMC' p $ A cs else A s
  transAMC p@(am,wam) s = A s
-- CMC: cons magic char
synCMC cs prefix = synCMC' $ genMagic cs prefix
synCMC' :: (c->Bool,c->F[c]->F[c]) -> F[c] -> F[c]
synCMC' p f = mapCons (transCMC p) f where
  transCMC p@(sm,wsm) m@(A [c]) yz@(C y z) = if sm c then wsm c y `C` z else m `C` yz
  transCMC p x y = C x y
withMagic prefix c y = A (prefix++[c]) `C` C y nil
genMagic magicChars prefix = ((`elem` magicChars),withMagic prefix)

---- naive printer
np :: S -> F S -> S
np [lg,rg,dot] (A "") = [lg,rg]
np [lg,rg,dot] (A s) = s
np p@[lg,rg,dot] (C x y) = [lg]++np p x++handle y++[rg] where
  handle (A "") = ""
  handle (A s) = ' ':dot:' ':s
  handle (C x' y') = (' ':np p x')++handle y'
pr = np "()."

---- haskell classes
instance Functor F where
  fmap f (A s) = A $ f s
  fmap f (C x y) = fmap f x `C` fmap f y
instance Applicative F where
  pure = A
  A fun <*> f = fmap fun f
  C fun fun' <*> a@(A _) = (fun<*>a) `C` (fun'<*>a)
  C fun fun' <*> C f f' = (fun<*>f) `C` (fun'<*>f')
instance Monad F where
  A s >>= fun = fun s
  C x y >>= fun = (x>>=fun) `C` (y>>=fun)
instance Foldable F where
  foldr fun initval (A s) = fun s initval
  foldr fun initval (C x y) = foldr fun initval' x where initval'=foldr fun initval y
